{-# LANGUAGE ViewPatterns, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
--
-- Module      :  LLVM.Code.Module
-- Copyright   :  Mikhail Belyaev
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module LLVM.Code.Module where



import LLVM.Code.Types (Type, TypeTable(..))
import LLVM.Code.Values
       (vtFromList, TypedValue(..), Value, ValueTable(..))
import LLVM.Code.ParamAttrs (emptyPB, emptyPA, ParamBlock(..))
import LLVM.Code.Symbolic
       (emptyVS, emptyTS, ValSymbolTable(..), TypeSymbolTable(..))
import LLVM.Parser.Record.Record
       (extrudeCustomSubblocksById, BlockType, RawBlock(..),
        BlockType(..), getBlockId, RawBlockElem(..), recordAsHeadlessList,
        RecordType(..), getCode, RawBlockElem, fromData, BlockHeader(..))
import LLVM.Code.MiscInfo
       (acGCName, acDepLib, acCodeSection, acModuleAsm, acDataLayout,
        acCodeModuleTriple, acVersion)
import LLVM.Code.Globals (GlobalDef(..))
import LLVM.Code.Function
       (collectFunctions, FunctionTable(..), FunctionDeclDef(..))
import LLVM.Code.Alias (AliasDef(..))
import Data.List (genericLength, genericDrop, genericReplicate)
import LLVM.Code.Constant (ConstantBlock(..))
import LLVM.Code.Shared (ValIndex(..))

import LLVM.Util
import Data.Generics(Typeable, Data)

data Module = Module {
                miscInfo        :: MiscModuleInfo,
                typetable       :: TypeTable,
                valuetable      :: ValueTable,
                functionBodies  :: FunctionTable,
                paramAttributes :: ParamBlock,
                typeSymbols     :: TypeSymbolTable,
                valSymbols      :: ValSymbolTable
              } deriving (Show, Eq, Typeable, Data)

data MiscModuleInfo = MiscModuleInfo {
                        version         :: Integer,
                        codeTriple      :: String,
                        dataLayout      :: String,
                        moduleAsm       :: [String],
                        codeSection     :: [String],
                        dependenceLib   :: [String],
                        gcName          :: [String]
                      } deriving (Show, Eq, Typeable, Data)

buildMMI :: RawBlock -> MiscModuleInfo
buildMMI RawBlock{header = BlockHeader{blockId = 8}, contents = elems} =
            MiscModuleInfo
                (getVersion ?? 0)
                (getTriple ?? "")
                (getDataLayout ?? "")
                (getASM)
                (getCS)
                (getDepLib)
                (getGCName)
            where
            records = maybeFilter fromData elems
            rhead [] = Nothing
            rhead (x:_) = Just x
            getAllWith func = maybeFilter func records
            getSmthWith func = rhead $ getAllWith func
            getVersion = getSmthWith acVersion
            getTriple = getSmthWith acCodeModuleTriple
            getDataLayout = getSmthWith acDataLayout
            getASM = getAllWith acModuleAsm
            getCS = getAllWith acCodeSection
            getDepLib = getAllWith acDepLib
            getGCName = getAllWith acGCName
buildMMI _ = MiscModuleInfo 0 "" "" [] [] [] []



-- this function is double-reversed!!! (reversed list on input, reversed list on output)
modValueTable :: TypeTable -> RawBlockElem -> [(Maybe (Type,Value))] -> [(Maybe (Type,Value))]
-- record with code 7 is a global
modValueTable tt (Data (fromRawRecord -> Just def@GlobalDef{})) (xs) = y:xs
    where y = (Just $ toTVPair def tt)
-- record with code 8 is a function
modValueTable tt (Data (fromRawRecord -> Just def@FunctionDeclDef{})) (xs) = y:xs
    where y = (Just $ toTVPair def tt)
-- record with code 9 is an alias
modValueTable tt (Data (fromRawRecord -> Just def@AliasDef{})) (xs) = y:xs
    where y = (Just $ toTVPair def tt)
-- record with code 10 is a purgeval record
modValueTable tt (Data rec) (xs) | getCode rec == Just 10 =
                                   case (recordAsHeadlessList rec) of
                                        (10:n:_)   | n > ln ->
                                                        genericReplicate (n-ln) Nothing ++ xs
                                                   | n < ln -> genericDrop (ln-n) xs
                                                   | n == ln -> xs
                                        _ -> xs
                                    where ln = genericLength xs
-- subblock with id 11 is constant block
modValueTable tt (Sub (mmatch -> (getBlockId -> 11, fromRawBlock -> (Just (cdefs -> cdefs))))) xs =
    reverse (map (Just . (`toTVPair` tt)) cdefs) ++ xs
modValueTable _ _ x = x

readModuleValueTable :: TypeTable -> RawBlock -> ValIndex -> ValueTable
readModuleValueTable tt rb start = vtFromList ret
                          where valkinds = foldr (modValueTable tt) [] $ rb.$contents
                                zipped = zip [start..] valkinds
                                cm (i, Just v) = Just (i,v)
                                cm (i, Nothing) = Nothing
                                ret = maybeFilter cm zipped

instance BlockType Module where
    -- block type of module has id of 8, block type of typetable has id of 10
    fromRawBlock rb@(getBlockId -> 8) =
                      Just Module{
                            miscInfo = info,
                            typetable = tt,
                            valuetable = vt,
                            functionBodies = funcs,
                            paramAttributes = pa,
                            typeSymbols = ts,
                            valSymbols = vs
                      }
                      where tt = (mayhead $ rb `extrudeCustomSubblocksById` 10 ++ rb `extrudeCustomSubblocksById` 17) ?? error "empty type table detected"
                            pa = (mayhead $ rb `extrudeCustomSubblocksById` 9) ?? emptyPB
                            ts = (mayhead $ rb `extrudeCustomSubblocksById` 13) ?? emptyTS
                            vs = (mayhead $ rb `extrudeCustomSubblocksById` 14) ?? emptyVS
                            vt = readModuleValueTable tt rb 0
                            info = rb.$buildMMI
                            funcs = collectFunctions rb tt vt
    fromRawBlock _ = Nothing



